COMMENT ⊗   VALID 00010 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00004 00003	! recover
C00006 00004	! symbol table: check,checktot,ensym,delsym,newsym,oldsym
C00017 00005	! symbol table: mk_pr, mk_rec, mk_sym, symtree routines
C00025 00006	! symbol table: gtframe,checkoff,arrydim
C00028 00007	! symbol table: nwr,dcdsym,unlink,linkfr,nwarec
C00034 00008	! symbol table: control,insertion,prdecl
C00040 00009	! symbol table: killtree,killvar,reset
C00044 00010		! affixes the frame pointed by n to the frame pointed by d, as indicated
C00045 ENDMK
C⊗;
ENTRY;
BEGIN "SYMBOL"
DEFINE $SYMBOL=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;

REQUIRE "⊂⊃⊂⊃" DELIMITERS;
DEFINE NVAL=0;
REDEFINE XX(A)=⊂ redefine nval=nval + a; nval ⊃;

REQUIRE "AIDEFS.SAI" SOURCE_FILE;
PRELOAD_WITH NVAL,XX(NO_OF_SCALARS),XX(NO_OF_VECTORS),XX(NO_OF_TRANSES),
		XX(NO_OF_TRANSES),XX(NO_OF_TRANSES),XX(NO_OF_EVENTS),
		XX(NO_OF_STRINGS),XX(NO_OF_CM),XX(NO_OF_MACROS),
		XX(NO_OF_FUNCTIONS),XX(NO_OF_DIMENSIONS);
INTEGER ARRAY ARR0[1:12];

PRELOAD_WITH NO_OF_SCALARS,NO_OF_VECTORS,NO_OF_TRANSES,NO_OF_TRANSES,
		NO_OF_TRANSES,NO_OF_EVENTS,NO_OF_STRINGS,NO_OF_CM,
		NO_OF_MACROS,NO_OF_FUNCTIONS,NO_OF_DIMENSIONS;
INTEGER ARRAY ARR1[1:11];	! maximum offsets and sizes ;

RPTR(SYMBOL)ARRAY SYMBOL_TABLE[1:NVAL];

INTERNAL RPTR(SYMBOL) PROCEDURE $YMPTR(INTEGER TYP,NUM);
	RETURN(SYMBOL_TABLE[ARR0[TYP]+NUM]);
DEFINE $YMREF(I,J)=⊂SYMBOL_TABLE[ARR0[I]+J]⊃;
! recover;
	! called when an indefined variable is used. Tries to recover, asking
	  the correct name of the variable, and returns it.
	  (null string or <control-C> to return to the main loop);


STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
	! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL;				! reads new identifier;
IFC #OUTPT THENC
	IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR);	! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
   THEN BEGIN
	PRINT("break character found. Try again ");
        GO TO CC;			! so... you can try again;
    	END
   ELSE IF SYMB THEN RETURN(SYMB);	! a "good" symbol is returned;
	! you want to delete the instruction being interpreted;
CLRBUF;
	IFC #DISPL THENC
		IF DEVICE≠DSK_X THEN $ALLOW←0;	! while reading display is not updated;
	ENDC
ESC_P;
ERROR("instruction not executed"&CRLF);
END "R";

! symbol table: check,checktot,ensym,delsym,newsym,oldsym;
	! checks if symbol symb, of type nm, is in symbol table in the class nm,
	  and return its pointer;

RPTR(SYMBOL)PROCEDURE CHCK(STRING SYMB; INTEGER TYPE; REFERENCE INTEGER COUNTER);
	BEGIN
	! checks for symbol SYMB as data type TYPE, and changes COUNTER
		to the entry in the symbol table;
	RPTR(SYMBOL)TEMP; INTEGER IND;
	IND←$ENTRY[TYPE];	! address of last record of type TYPE filled ;
	FOR COUNTER←1 STEP 1 UNTIL IND DO
		IF (TEMP←$YMPTR(TYPE,COUNTER)) AND EQU(SYMBOL:PNAME[TEMP],SYMB)
			THEN RETURN(TEMP);
	COUNTER←0;
	RETURN(NULL_RECORD);
	END;

INTERNAL RPTR(SYMBOL)PROCEDURE CHCKDIM(RPTR(DIMENS)DIMENSIONS);
	BEGIN INTEGER I; RPTR(SYMBOL)TEMP;
	FOR I←1 STEP 1 UNTIL $ENTRY[#DM] DO
		IF (TEMP←$YMPTR(#DM,I))
			AND EQU_DIMENS(DIMENSIONS,SYMBOL:OBJECT[TEMP])
		THEN RETURN(TEMP);
	RETURN(DIMENS:SYM[NIL_DIMENS]);
	END;

INTERNAL RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER TYPE);
	BEGIN
	! checks if SYMB is an identifier of type TYPE ;
	INTEGER I;
	RETURN(CHCK(SYMB,TYPE,I));
	END;

 	! checks if symbol symb is in symbol table, determines its class and
	  return its pointer;


RPTR(SYMBOL)PROCEDURE CHCKTOT(STRING SYMB; REFERENCE INTEGER TYPE,COUNTER);
	BEGIN
	INTEGER TYPE,COUNTER;RPTR(SYMBOL)TEMP;
	FOR TYPE←#MIN STEP 1 UNTIL #MAX DO
	    IF (TEMP←CHCK(SYMB,TYPE,COUNTER)) THEN RETURN(TEMP);
	TYPE←0;
	RETURN(NULL_RECORD);			! symbol not found;
	END;

INTERNAL RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB);
	BEGIN INTEGER I,J;
	RETURN(CHCKTOT(SYMB,I,J));
	END;

INTERNAL BOOLEAN PROCEDURE UNDECLARED(STRING NAME);
	RETURN(IF CHECKTOT(NAME)=NULL_RECORD THEN TRUE ELSE FALSE);

! given an array element returns the name of the array;
INTERNAL STRING PROCEDURE ARNAME(STRING EL_NAME);
	BEGIN
	INTEGER I,BR;STRING TEMP;
	SETBREAK(I←GETBREAK,"[",NULL,"IS");
	TEMP←SCAN(EL_NAME,I,BR); RELBREAK(I);
	RETURN(TEMP);
	END;

! return the symbol pointer. If EL_NAME is an array element return the pointer to
  the array in the symbol table;
INTERNAL RPTR(SYMBOL)PROCEDURE $YM_PTR(STRING EL_NAME);
	RETURN(CHECKTOT(ARNAME(EL_NAME)));

! return the symbol pointer of NAME. If NAME is an array element return the pointer
  to the array element (taken from ARRAYREC:PTR);
INTERNAL RPTR(SYMBOL)PROCEDURE SYM_PTR_OF(STRING NAME);
	BEGIN
	RPTR(SYMBOL) SYMB;RPTR(ARRAYREC)ARR; 
	IF (SYMB←$YM_PTR(NAME))=NULL_RECORD 
	   THEN RETURN(SYMB)
	   ELSE BEGIN
		CASE SYMBOL:ACCESS[SYMB] OF BEGIN "case"
		[#SIMPLE] [#PROCEDURE] RETURN(SYMB);
		[#ARRAY]  BEGIN
			INTEGER #DIM,I,J,BR;STRING AR_PARAM;
			AR_PARAM←NAME[LENGTH(SYMBOL:PNAME[SYMB])+1 TO ∞];
			#DIM←ARRAYREC:#DIM[ARR←SYMBOL:OBJECT[SYMB]];J←0;
			FOR I←1 STEP 1 UNTIL #DIM DO 
			  J←J+(INTSCAN(AR_PARAM,BR)-ARRAYREC:LB[ARR][I])
					*ARRAYREC:MUL[ARR][I];
			RETURN(ARRAYREC:PTR[ARR][J+1]);
			END;
		[#ARRAY_ELEMENT] ERROR("ERROR in SYMBOL TABLE: #ARRAY ELEMENT found")
			end "case";
		END;
	END;

	! enters the symbol symb and the pointer to its node in symbol table,
	  in the class nm. The record of the class SCALAR,VECTOR,ROT,TRANS or
	  FRAME has to be constructed before calling ENSYM;


INTEGER PROCEDURE NEW_OFFSET(INTEGER NM);
	BEGIN
	INTEGER I;
	IF NM≠#MC THEN
	IF OFFSET[CUR_OFFSET,NM]=ARR1[NM] 
		THEN ERROR("NO MORE SPACE FOR NEW SYMBOLS IN 11");
	CASE NM OF
	    BEGIN
	    [#SC][#VT][#EV][#ST][#MC][#DM]
		OFFSET[CUR_OFFSET,NM]←OFFSET[CUR_OFFSET,NM]+1;
	    [#RT][#TR][#FR]
		FOR I← 3 STEP 1 UNTIL 5 DO OFFSET[CUR_OFFSET,I]←OFFSET[CUR_OFFSET,I]+1;
	    [#PR][#CM] I←I
	    END;
	RETURN(OFFSET[CUR_OFFSET,NM]);
	END;

INTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL;
	RPTR(SYMBOL)OLDREC(NULL_RECORD); INTEGER ACCESS(#SIMPLE));
	BEGIN
	RPTR (SYMBOL) TEMP;INTEGER IND;
	IF $ENTRY[NM]≥ARR1[NM]
	   THEN ERROR("insufficient space in symbol table");
	IF OLDREC THEN TEMP←OLDREC ELSE	TEMP←NEW_RECORD(SYMBOL);
	$YMREF(NM,($ENTRY[NM]←$ENTRY[NM]+1))←TEMP; ! pointer to the new record
					 in SYMBOL TABLE ;
!		SYMBOL:VALID[TEMP]←TRUE;
	SYMBOL:TYPE[TEMP]←NM;
	SYMBOL:PNAME[TEMP]←SYMB;	! pname of symbol;
	SYMBOL:OBJECT[TEMP]←VAL;	! pointer to the record previously created;
	IF ACCESS=#SIMPLE AND #MIN≤NM≤#BASIC_TYPES THEN
		BEGIN  SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
		       SYMBOL:OFFSET[TEMP]←ARROFF[NM];
		END
	ELSE IF NM=#MC OR NM=#DM THEN SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
	RETURN(TEMP);
	END;


INTERNAL PROCEDURE ENSYM$(RPTR(SYMBOL)SYM; INTEGER NM(0));
	BEGIN
	INTEGER IND;
	IF NM=0 THEN NM←SYMBOL:TYPE[SYM] ELSE SYMBOL:TYPE[SYM]←NM;
	IF $ENTRY[NM]≥ARR1[NM]
	   THEN ERROR("insufficient space in symbol table");
	IF NM=#FR AND SYMBOL:ACCESS[SYM]=#SIMPLE
	   THEN IF SYM≠ WORLD THEN LINKFR(SYMBOL:OBJECT[SYM],F_WRLD);
	$YMREF(NM,($ENTRY[NM]←$ENTRY[NM]+1))←SYM;	! pointer to the new record in $YMTAB;
	IF SYMBOL:ACCESS[SYM]=#SIMPLE AND  #MIN≤NM≤#BASIC_TYPES THEN
		BEGIN  SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
		       SYMBOL:OFFSET[SYM]←ARROFF[NM];
		END
	ELSE IF (NM=#MC) OR (NM=#CM) THEN SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
	END;

	! returns a new symbol, if symb is present in SYMBOL TABLE.
	 Id used before 
	  inserting a new symbol in SYMBOL TABLE to be sure that a symbol with the 
	  name has not been defined before. This procedure allows recovering;

INTERNAL STRING PROCEDURE NEWSYM(STRING SYMB);
	BEGIN
	RPTR(SYMBOL)TEMP;
	! if there is a symbol with the same pname allows recovering;
	WHILE (TEMP←CHECKTOT(SYMB))≠NULL_RECORD 
	     DO BEGIN
	        PRINT(SYMB," has already been defined");
		SYMB←RECOVER(SYMB);
		END;
	RETURN(SYMB);
	END;

	! checks if symb is present in SYMBOL TABLE
	 and returns its pointer and its
	  type (using the reference variable obtype), otherwise allows recovering.
	  Is used when the symbol required has to be present in SYMBOL TABLE
	 (ex. in EDIT or RENAME instruction);

INTERNAL RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL)EL;
	EL←CHECKTOT(SYMB);
	! if symbol is not in SYMBOL TABLE, recovering is allowed;
	WHILE (EL←CHECKTOT(SYMB))=NULL_RECORD
	     DO BEGIN
		PRINT(" object not existent ");
		SYMB←RECOVER(SYMB);
		END;
	OBTYPE←SYMBOL:TYPE[EL];
	RETURN(EL);
	END;


INTERNAL PROCEDURE DELSYM(RPTR(SYMBOL)EL);
	BEGIN
	INTEGER ADDRFN,I;
	INTEGER OBTYPE; OBTYPE←SYMBOL:TYPE[EL];
	ADDRFN← $ENTRY[OBTYPE];	! final addr. in $YMTAB for class;
	FOR I←1 STEP 1 UNTIL ADDRFN DO
	IF $YMPTR(OBTYPE,I)=EL 
	   THEN BEGIN
		$YMREF(OBTYPE,I)←$YMPTR(OBTYPE,ADDRFN);
		$ENTRY[OBTYPE]←ADDRFN-1;	! move last element into hole;
!		SYMBOL:VALID[EL]←FALSE;
		DONE;
		END;
	END;

! symbol table: mk_pr, mk_rec, mk_sym, symtree routines;

	! produces a symbol record with certain fields filled in ;
INTERNAL RPTR(SYMBOL)PROCEDURE MK_SYM(STRING PNAME; INTEGER TYPE;
		RANY PTR(NULL_RECORD); INTEGER ACCESS(#SIMPLE));
	BEGIN
	RPTR(SYMBOL)SYM;
	SYM←NEW_RECORD(SYMBOL);
	SYMBOL:PNAME[SYM]←PNAME;
	SYMBOL:TYPE[SYM]←TYPE;
	SYMBOL:OBJECT[SYM]←PTR;
	SYMBOL:ACCESS[SYM]←ACCESS;
	RETURN(SYM);
	END;

INTERNAL RPTR(PROC)PROCEDURE MK_PR(INTEGER ARGS,NON_DEFAULT_ARGS;
	STRING ARRAY ARGNAME,DEFAULT_ARG;
	INTEGER ARRAY ARGTYPE,ARGACCS,ARGDIM;
	RPTR(DIMENS)ARRAY ARG_DIMENS);
IF ARGS=0 THEN RETURN(NEW_RECORD(PROC)) ELSE
	BEGIN
	RPTR(PROC)E;
	STRING ARRAY S,DA[1:ARGS];
	INTEGER ARRAY T,C,D[1:ARGS];
	RPTR(DIMENS)ARRAY AG[1:ARGS];
	ARRTRAN(S,ARGNAME);
	ARRTRAN(DA,DEFAULT_ARG);
	ARRTRAN(T,ARGTYPE);
	ARRTRAN(C,ARGACCS);
	ARRTRAN(D,ARGDIM);
	ARRTRAN(AG,ARG_DIMENS);
	E←NEW_RECORD(PROC);
	PROC:NARGS[E]←ARGS;
	PROC:NON_DEFAULT_ARGS[E]←NON_DEFAULT_ARGS;
	MEMORY[LOCATION(PROC:ARGNAME[E])]↔MEMORY[LOCATION(S)];
	MEMORY[LOCATION(PROC:ARGDIM[E])]↔MEMORY[LOCATION(D)];
	MEMORY[LOCATION(PROC:ARGACCS[E])]↔MEMORY[LOCATION(C)];
	MEMORY[LOCATION(PROC:ARGTYPE[E])]↔MEMORY[LOCATION(T)];
	MEMORY[LOCATION(PROC:DEFAULT_ARG[E])]↔MEMORY[LOCATION(DA)];
	MEMORY[LOCATION(PROC:ARGDIMENS[E])]↔MEMORY[LOCATION(AG)];
	RETURN(E);
	END;

INTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,CMON,PSTRING,DIMENS) PROCEDURE MK_REC(INTEGER TYPE);
	BEGIN
	RANY TEMP;
	REAL ARRAY XF[1:6];
	CASE TYPE OF 
	begin "case"
	[#SC] TEMP←NEW_RECORD(SCALAR);
	[#VT] TEMP←NEW_RECORD(VECTOR);
	[#RT] BEGIN
		TEMP←NEW_RECORD(ROT);
		MEMORY[LOCATION(ROT:XF[TEMP])]←MEMORY[LOCATION(XF)];
		END;
	[#TR] BEGIN
		TEMP←NEW_RECORD(TRANS);
		MEMORY[LOCATION(TRANS:XF[TEMP])]←MEMORY[LOCATION(XF)];
		END;
	[#FR] BEGIN
		TEMP←NEW_RECORD(FRAME);
		MEMORY[LOCATION(FRAME:XF[TEMP])]←MEMORY[LOCATION(XF)];
! insert here the affixment to the world;
		FRAME:HOWLINKED[TEMP]←#INDLK;		! independently;
		END;
!	[#MC]	TEMP←NEW_RECORD(MACRO);
	[#FN]	TEMP←NEW_RECORD(PROC);
	[#EV]	TEMP← NULL_RECORD;	! No record needed for EVENTs;
	[#CM]	TEMP←NEW_RECORD(CMON);
	[#ST]	TEMP←NEW_RECORD(PSTRING);
	[#DM]	TEMP←NEW_RECORD(DIMENS);
	ELSE	ERROR("PARSER ERROR, NO SUCH RECORD CLASS IN MK_REC")
	end "case";
	IF TYPE=#RT OR TYPE=#TR OR TYPE =#FR THEN MEMORY[LOCATION(XF)]←0;
	RETURN(TEMP);
	END;

RPTR(SYMTREE)PROCEDURE MK_SYMTREE(RPTR(SYMBOL)S);
	BEGIN
	RPTR(SYMTREE)E;
	SYMTREE:SYM[E←NEW_RECORD(SYMTREE)]←S;
	RETURN(E);
	END;

RECURSIVE PROCEDURE INSRTTREE(RPTR(SYMBOL)S; RPTR(SYMTREE)STREE);
	BEGIN
	RPTR(SYMTREE)SS;
	CASE COMPEQU(SYMBOL:PNAME[S],SYMBOL:PNAME[SYMTREE:SYM[STREE]])+1 OF
		BEGIN
		[-1+1]	IF (SS←SYMTREE:LLINK[STREE])=NULL_RECORD
				THEN SYMTREE:LLINK[STREE]←MK_SYMTREE(S)
				ELSE INSRTTREE(S,SS);
		[0+1]	ERROR("ugh trying to insert element ");
		[1+1]	IF (SS←SYMTREE:RLINK[STREE])=NULL_RECORD
				THEN SYMTREE:RLINK[STREE]←MK_SYMTREE(S)
				ELSE INSRTTREE(S,SS)
		END;
	END;

INTERNAL PROCEDURE INSRTSYMTREE(RPTR(SYMBOL)S;RPTR(BLOCKREC)STREE);
	BEGIN
	IF BLOCKREC:TREE[STREE]=NULL_RECORD
	  THEN BLOCKREC:TREE[STREE]←MK_SYMTREE(S)
	  ELSE INSRTTREE(S,BLOCKREC:TREE[STREE]);
	BLOCKREC:#ARGS[STREE]←BLOCKREC:#ARGS[STREE]+1;
	END;

INTERNAL RPTR(BLOCKREC)PROCEDURE BLOCKIFY(INTEGER NARGS; RPTR(SYMBOL)ARRAY SYMARR;
		RPTR(BLOCKREC)BLOCK(NULL_RECORD));
	BEGIN INTEGER I;
	RPTR(BLOCKREC)BLOCKPTR;
	IF BLOCK THEN BLOCKPTR←BLOCK ELSE BLOCKPTR←NEW_RECORD(BLOCKREC);
	FOR I←1 STEP 1 UNTIL NARGS DO
		INSRTSYMTREE(SYMARR[I],BLOCKPTR);
	RETURN(BLOCKPTR);
	END;

RPTR(SYMBOL)RECURSIVE PROCEDURE SEARCHSYMTREE(STRING S; RPTR(SYMTREE)STREE);
    IF STREE=NULL_RECORD
	THEN RETURN(NULL_RECORD)
	ELSE CASE COMPEQU(S,SYMBOL:PNAME[SYMTREE:SYM[STREE]]) +1 OF
		BEGIN
		[-1+1]	RETURN(SEARCHSYMTREE(S,SYMTREE:LLINK[STREE]));
		[0+1]	RETURN(SYMTREE:SYM[STREE]);
		[1+1]	RETURN(SEARCHSYMTREE(S,SYMTREE:RLINK[STREE]))
		END;

INTERNAL RPTR(SYMBOL)PROCEDURE SEARCHBLOCK(STRING S; RPTR(BLOCKREC)R);
	RETURN(SEARCHSYMTREE(S,BLOCKREC:TREE[R]));

RPTR(SYMBOL)RECURSIVE PROCEDURE SEARCHSYMTREEOFF(INTEGER I; RPTR(SYMTREE)STREE);
	IF STREE=NULL_RECORD
	    THEN RETURN(NULL_RECORD)
	    ELSE IF I=SYMBOL:OFFSET[SYMTREE:SYM[STREE]]
		THEN RETURN(SYMTREE:SYM[STREE])
		ELSE BEGIN
			RPTR(SYMBOL)S;
			IF S←SEARCHSYMTREEOFF(I,SYMTREE:LLINK[STREE])
			    THEN RETURN(S)
			    ELSE RETURN(SEARCHSYMTREEOFF(I,SYMTREE:RLINK[STREE]))
		     END;

RPTR(SYMBOL)PROCEDURE SEARCHBLOCKOFF(INTEGER I; RPTR(BLOCKREC)R);
	IF R THEN RETURN(SEARCHSYMTREEOFF(I,BLOCKREC:TREE[R]))
		ELSE RETURN(NULL_RECORD);

! symbol table: gtframe,checkoff,arrydim;

INTERNAL RPTR(FRAME) PROCEDURE GTFRAME(INTEGER LEVOFF,#DIM; INTEGER ARRAY DIM;
				RPTR(SYMBOL)S);
	IF LEVOFF=ARROFF[#FR] THEN
		BEGIN
		RPTR(SYMBOL)TEMP;
		INTEGER I;
		FOR I←1 STEP 1 UNTIL $ENTRY[#FR] DO
			IF DIM[1]=SYMBOL:INDEX[TEMP←$YMPTR(#FR,I)] THEN
				RETURN(SYMBOL:OBJECT[TEMP]);
		RETURN(NULL_RECORD);
		END
	ELSE BEGIN "array or temporary"
		! not quite reight, this only assumes arrays;
		RPTR(ARRAYREC)ARR;
		INTEGER I,J;
		IF NOT S THEN ERROR("ERROR n GTFRAME: cant handle temporary variables yyet");
		ARR←SYMBOL:OBJECT[S];
		J←0;
		FOR I←1 STEP 1 UNTIL #DIM
			DO J←J+(DIM[I]-ARRAYREC:LB[ARR][I])*ARRAYREC:MUL[ARR][I];
		RETURN(SYMBOL:OBJECT[ARRAYREC:PTR[ARR][J+1]]);
	     END "array or temporary";

	! returns the symbol for given offset;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECKOFF(INTEGER LEVOFF);
	BEGIN
	RPTR(SYMBOL) TEMP; INTEGER I,J;
! REMEMBER TO TAKE CARE OF LOCAL VARIABLES;
	IF CURBLOCK AND TEMP←SEARCHBLOCKOFF(LEVOFF,CURBLOCK) THEN RETURN(TEMP);
	FOR I←#MIN STEP 1 UNTIL #MAX DO
		FOR J←1 STEP 1 UNTIL $ENTRY[I]
		DO IF (TEMP←$YMPTR(I,J)) AND SYMBOL:OFFSET[TEMP]=LEVOFF
			THEN RETURN(TEMP);
	RETURN(NULL_RECORD);
	END;

	! returns number of dimensions in symbol table for the leveloffset given;
INTERNAL INTEGER PROCEDURE ARRYDIM(INTEGER LEVOFF;REFERENCE RPTR(SYMBOL) SYM);
	BEGIN
	SYM←NULL_RECORD;
	IF LEVOFF=ARROFF[#SC] OR LEVOFF=ARROFF[#VT] OR LEVOFF=ARROFF[#RT]
		OR LEVOFF=ARROFF[#TR] OR LEVOFF=ARROFF[#FR]
		THEN RETURN(1)
		ELSE IF SYM←CHECKOFF(LEVOFF)
			THEN IF SYMBOL:ACCESS[SYM]=#SIMPLE THEN RETURN(0)
			ELSE RETURN(ARRAYREC:#DIM[SYMBOL:OBJECT[SYM]])
		ELSE RETURN(0);
	END;

! symbol table: nwr,dcdsym,unlink,linkfr,nwarec;

PROCEDURE UNLINK(RPTR(FRAME) N);
	BEGIN
	RPTR(FRAME) Y,E;
 	E←FRAME:EBRO[N];
 	IF (Y←FRAME:YBRO[N])≠NULL_RECORD 
	   THEN FRAME:EBRO[Y]←E
	   ELSE IF FRAME:DAD[N]≠NULL_RECORD THEN FRAME:SON[FRAME:DAD[N]]←E;
	IF E≠NULL_RECORD THEN FRAME:YBRO[E]←Y;
 	FRAME:EBRO[N]←NULL_RECORD;
 	FRAME:YBRO[N]←NULL_RECORD;
 	FRAME:DAD[N]←NULL_RECORD;
	END;

BOOLEAN PROCEDURE IS_ANCESTOR(RPTR(FRAME) N,D);
	BEGIN
	WHILE N≠NULL_RECORD DO
		IF N=D	THEN RETURN(TRUE) 
			ELSE N←FRAME:DAD[N];
	RETURN(FALSE);
	END;

	! sets #UP pointer structure in frame tree for N to be a child of D;

INTERNAL PROCEDURE LINKFR(RPTR(FRAME) N,D);	
	BEGIN
	IF NOT(D=F_WRLD AND FRAME:HOWLINKED[N]=#INDLK) 
	   THEN IF IS_ANCESTOR(D,N)
 		   THEN ERROR(" backwards affixment to"&frame:pname[D]);
        IF FRAME:DAD[N]≠NULL_RECORD THEN UNLINK(N);
 	IF (FRAME:EBRO[N]←FRAME:SON[D])≠NULL_RECORD THEN
 		FRAME:YBRO[FRAME:EBRO[N]]←N;
 	FRAME:YBRO[N]←NULL_RECORD;
 	FRAME:DAD[N]←D;
 	FRAME:SON[D]←N;
	END;


RPTR(TRANS) PROCEDURE ABSLOC(RPTR(FRAME) ND);
	BEGIN
	PRINT("DUMMY ABSLOC"); RETURN(NULL_RECORD);	END;

RPTR(SYMBOL)PROCEDURE NWR(STRING SYMB; INTEGER TYP);
	BEGIN
	RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
	SYMB←NEWSYM(SYMB);
	VAL←MK_REC(TYP);
	TEMP←ENSYM(SYMB,TYP,VAL);
	IF TYP=#FR THEN BEGIN FRAME:PNAME[VAL]←SYMB;
			IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
			FRAME:PNAME[VAL]←SYMB;
			FRAME:HOWLINKED[VAL]←#INDLK;
			FRAME:SYM[VAL]←TEMP;
			END;
	$DISPLAYLIST[TYP]←NULL;
	RETURN(TEMP);
	END;

	! like nwr but does not insert into symbol table;
INTERNAL RPTR(SYMBOL)PROCEDURE NNWR(STRING SYMB; INTEGER TYP; INTEGER ACCESS(#SIMPLE));
	BEGIN
	RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,CMON)VAL; RPTR(SYMBOL)TEMP;
	TEMP←MK_SYM(SYMB,TYP,VAL←MK_REC(TYP),ACCESS);
	IF TYP=#FR THEN BEGIN
			! the frame is affixed in ENSYM$;
			FRAME:PNAME[VAL]←SYMB;
			FRAME:HOWLINKED[VAL]←#INDLK;
			FRAME:SYM[VAL]←TEMP;
			END;
	RETURN(TEMP);
	END;


INTERNAL RPTR(SYMBOL)PROCEDURE NWAREC(RPTR(SYMBOL)TEMP;INTEGER #EL;
		INTEGER ARRAY LB,UB,MULT; RPTR(DIMENS)DIMENSIONS);
	BEGIN
	RPTR(ARRAYREC)VAL;
	INTEGER TYP,#DIM,OFFSET;
	OFFSET←SYMBOL:OFFSET[TEMP];
	VAL←SYMBOL:OBJECT[TEMP];
	TYP←SYMBOL:TYPE[TEMP];
	#DIM←ARRAYREC:#DIM[VAL];
		BEGIN
		INTEGER ARRAY ALB,AUB,MUL[1:5];
		INTEGER ARRAY I[1:5];
		INTEGER J,JJ;
		STRING S1,S2;
		RPTR(SYMBOL) ARRAY PTR[1:#EL];
		ARRBLT(ALB[1],LB[1],#DIM);
		ARRBLT(AUB[1],UB[1],#DIM);
		ARRBLT(MUL[1],MULT[1],#DIM);
		S1←SYMBOL:PNAME[TEMP]&"[";
		JJ←0;
		FOR I[1]←ALB[1] STEP 1 UNTIL AUB[1] DO
		FOR I[2]←ALB[2] STEP 1 UNTIL AUB[2] DO
		FOR I[3]←ALB[3] STEP 1 UNTIL AUB[3] DO
		FOR I[4]←ALB[4] STEP 1 UNTIL AUB[4] DO
		FOR I[5]←ALB[5] STEP 1 UNTIL AUB[5] DO
			BEGIN
			S2←S1&CVS(I[1]);
			FOR J←2 STEP 1 UNTIL #DIM DO
				S2←S2&","&CVS(I[J]);
			S2←S2&"]";
			SYMBOL:OFFSET[PTR[JJ←JJ+1]←NNWR(S2,TYP,#ARRAY_ELEMENT)]
				← OFFSET;
			SYMBOL:DIMENS[PTR[JJ]]←DIMENSIONS;
			IF TYP=#FR THEN
				LINKFR(SYMBOL:OBJECT[PTR[JJ]],F_WRLD);
			END;
		ARRAYREC:#EL[VAL]←#EL;
		MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
		MEMORY[LOCATION(ARRAYREC:LB[VAL])]↔MEMORY[LOCATION(ALB)];
		MEMORY[LOCATION(ARRAYREC:UB[VAL])]↔MEMORY[LOCATION(AUB)];
		MEMORY[LOCATION(ARRAYREC:MUL[VAL])]↔MEMORY[LOCATION(MUL)];
		END;
	RETURN(TEMP);
	END;
! symbol table: control,insertion,prdecl;

INTERNAL BOOLEAN PROCEDURE PRDECL(RPTR(SYMBOL) OB1);
	IF SYMBOL:TYPE[OB1]=#PR OR SYMBOL:TYPE[OB1]=#MC OR SYMBOL:TYPE[OB1]=#EV
		THEN RETURN(FALSE)
	ELSE
	RETURN((SYMBOL:OFFSET[OB1]<'400) OR
		(OFFSET[PRG_OFFSET,SYMBOL:TYPE[OB1]]
	<SYMBOL:INDEX[OB1]≤OFFSET[CON_OFFSET,SYMBOL:TYPE[OB1]]));

INTERNAL RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
	BEGIN
	RPTR(TRANS) TEMP;RPTR(SYMBOL)EL2;
	TEMP←SYMBOL:OBJECT[EL];
	IF SYMBOL:OFFSET[EL]≥'1000
	    THEN ERROR("CANT convert trans to frame for local variables");
	EL2←NNWR(SYMB,#FR);
	ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL2]],TRANS:XF[TEMP]);
	SYMBOL:INDEX[EL2]←SYMBOL:INDEX[EL];
	SYMBOL:OFFSET[EL2]←SYMBOL:OFFSET[EL];
	SYMBOL:ACCESS[EL2]←SYMBOL:ACCESS[EL];

	DELSYM(EL);	! delete from symbol table;
	$YMREF(#FR,($ENTRY[#FR]←$ENTRY[#FR]+1))←EL2;
	$FRLST←$TRLST←NULL;
	RETURN(EL2);
	END;


	! if the symbol symb is present in SYMBOL TABLE in the class OBTYPE returns
	  the pointer to it, otherwise allows recovering. The symbol is passed 
	  by reference so after recovering the new symbol is sent back;

RPTR(SYMBOL) PROCEDURE BELONGS2(REFERENCE STRING SYMB;INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL) EL;
	EL←CHECK(SYMB,OBTYPE);		! checks if symbol is present;
	WHILE EL=NULL_RECORD
	     DO BEGIN
		IF OBTYPE=#FR
		   THEN BEGIN
			EL←CHECK(SYMB,#TR);
			IF EL 
			   THEN BEGIN
				EL←CNVRTR(EL,SYMB);
				RETURN(EL);
				END;
			END;
		PRINT($DTYPE[OBTYPE]&" required");
		SYMB←RECOVER(SYMB);	! recover can interrupt the loop and abort;
		EL←CHECK(SYMB,OBTYPE);
		END;
	RETURN(EL);	! returns the pointer to the symbol;
	END;

INTERNAL RANY PROCEDURE BELONGS(REFERENCE STRING SYMB; INTEGER OBTYPE);
	RETURN(SYMBOL:OBJECT[BELONGS2(SYMB,OBTYPE)]);

	! checks if the symbol (scalar,vector or rotation) is in SYMBOL TABLE
	  If not inserts it, and returns its pointer;	

INTERNAL RPTR(SYMBOL) PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL)EL;
	IF OBTYPE=#FR THEN
		BEGIN RPTR(FRAME)FR1; STRING S1;
			S1←SYMB;
			FR1←FR_INSERT(S1);
			RETURN(CHECK(S1,OBTYPE));
		END;
	EL←CHECK(SYMB,OBTYPE);
	IF EL=NULL_RECORD THEN EL←NWR(SYMB,OBTYPE);
	RETURN(EL);
	END;

	! returns the pointer to the frame. If the frame is not present inserts it,
	  otherwise checks its affixment type  and asks for a confirmation if
	  the affixment type is not independent. In that case recovering is allowed;

INTERNAL RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
	BEGIN "A"
	RPTR(SYMBOL) EL;
	RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
	WHILE TRUE 
	     DO	BEGIN "LOOP"
		EL←CHECK(SYMB,#FR);			! if while copying;
		WHILE EL≠NULL_RECORD
			     DO	BEGIN
				! while copying a new frame is required.
				  Recovering is allowed if the frame is existent;
				PRINT("symbol has already been defined");
				SYMB←RECOVER(SYMB);	
				EL←CHECK(SYMB,#FR);
				END;
		IF EL=NULL_RECORD
		   THEN BEGIN
			EL←CHECK(SYMB,#TR);
			IF EL THEN EL←CNVRTR(EL,SYMB)
			   ELSE EL←NWR(SYMB,#FR);		! defines a new frame;
			   RETURN(SYMBOL:OBJECT[EL]);
			END
		   ELSE BEGIN "C"
			FRA←SYMBOL:OBJECT[EL];
			LINK←FRAME:HOWLINKED[FRA];
			! changing values of the frame is allowed if link is #INDLK;
			IF LINK=#INDLK
			   THEN	BEGIN
				$FRLST←NULL;
				RETURN(FRA);
				END
			   ELSE BEGIN
				! otherwise a confirmation is required;
				PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
				"You can change the name ");
				TEMP←RECOVER(SYMB);
				! if the name of the frame is the same, 
				  changing values is allowed;
				IF EQU(TEMP ,SYMB) 
				   THEN BEGIN
					$FRLST←NULL;
					RETURN(FRA);
					END
				   ELSE SYMB←TEMP;
				END;
			END "C";
		END "LOOP";
	END "A";

! symbol table: killtree,killvar,reset;

	! removes from SYMBOL TABLE all nodes in the subtrees rooted at el;

RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
	BEGIN
	RPTR(FRAME)TEMP; RPTR(SYMBOL)E;
	TEMP←SYMBOL:OBJECT[E←EL];
	DELSYM(EL);				! removes el from $YMTAB;
	TEMP←FRAME:SON[TEMP];
	WHILE TEMP≠NULL_RECORD DO
		BEGIN
		EL←CHECK(FRAME:PNAME[TEMP],#FR);
		KILLTREE(EL);
		TEMP←FRAME:EBRO[TEMP];
		END;
	END;

	! removes the symbol from SYMBOL TABLE ;

INTERNAL PROCEDURE KILLVAR(RPTR(SYMBOL)EL);
	BEGIN ! before calling this routine make sure that you are not deleting a pointy declared variable ;
	IF SYMBOL:TYPE[EL]≠#FR 
		THEN DELSYM(EL)
		ELSE BEGIN
			IF SYMBOL:ACCESS[EL]≠#SIMPLE THEN
				ERROR("Can only kill simple frames unless you kill all frames");
			UNLINK(SYMBOL:OBJECT[EL]);	! unfixes the frame;
			KILLTREE(EL);  		! deletes subtrees rooted in var;
			END;
	$DISPLAYLIST[SYMBOL:TYPE[EL]]←NULL;
	END;

	! the procedure deletes all the variables defined by the user. It's
	  called by DELETE with no arguments.;

INTERNAL PROCEDURE RESET;
	BEGIN
	INTEGER IND,TEMP; RPTR(SYMBOL)EL;
	! frames are handled differently because of the affixment;
	IND←$ENTRY[#FR];
	FOR TEMP←OFFSET[RES_OFFSET,#FR]+1 STEP 1 UNTIL IND DO
	    CASE SYMBOL:ACCESS[EL←$YMPTR(#FR,TEMP)] OF
		BEGIN
		    [#SIMPLE]	UNLINK(SYMBOL:OBJECT[EL]);
		    [#ARRAY]
			BEGIN ! must be array;
			     RPTR(ARRAYREC)A;
			     INTEGER I;
			     A←SYMBOL:OBJECT[EL];
			     FOR I←1 STEP 1 UNTIL ARRAYREC:#EL[A] DO
				UNLINK(SYMBOL:OBJECT[ARRAYREC:PTR[A][I]]);
			     END;
		    [#PROCEDURE] ;
		    ELSE
		END;
	FOR IND←#MIN STEP 1 UNTIL #MAX DO
	    BEGIN
	    $ENTRY[IND]←OFFSET[RES_OFFSET,IND];
	    $DISPLAYLIST[IND]←NULL;
	    END;
	END;
	! affixes the frame pointed by n to the frame pointed by d, as indicated
	  by how;
INTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
	BEGIN
	LINKFR(N,D);				! sets links in frame tree;
	FRAME:HOWLINKED[N]←HOW;
	END;

INTERNAL PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
	BEGIN
	UNLINK(EL1);				! breaks links in tree;
	FRAME:HOWLINKED[EL1]←#INDLK;
	LINKFR(EL1,F_WRLD);			! sets new links;
	END;

END "SYMBOL";